home *** CD-ROM | disk | FTP | other *** search
/ Ham Radio 2000 #1 / Ham Radio 2000.iso / ham2000 / packet / terminal / gp161b / eliza.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1993-09-13  |  9.8 KB  |  309 lines
  1. {$A+,B-,D-,E-,F-,G-,I-,L-,N-,O-,R-,S-,V-,X-}
  2. {$M 1024,0,0}
  3.  
  4. program Eliza;
  5.  
  6. USES Dos,GPRI;
  7.  
  8. {=========================================================}
  9. {      Keywords                                           }
  10. {=========================================================}
  11. const MaxKey = 37;
  12. type KeyWordArray = array[1..MaxKey] of string[14];
  13. const KeyWords : KeyWordArray = (
  14.                'CAN YOU','CAN I','YOU ARE','YOU''RE','I DON''T',
  15.                'I FEEL','WHY DON''T YOU','WHY CAN''T I','ARE YOU',
  16.                'I CAN''T','I AM','I''M','YOU','I WANT','WHAT',
  17.                'HOW','WHO','WHERE','WHEN','WHY','NAME','CAUSE',
  18.                'SORRY','DREAM','HELLO','HI','MAYBE','NO',
  19.                'YOUR','ALWAYS','THINK','ALIKE','YES','FRIEND',
  20.                'COMPUTER','NO KEY FOUND','REPEAT INPUT');
  21.  
  22. {=========================================================}
  23. {     Data for finding the right responses                }
  24. {=========================================================}
  25.  
  26. const RespFn = 'response.dat';   {response data file}
  27.       MaxRespNum = 116;
  28.  
  29. type KeyNumArray = array[1..MaxKey] of word;
  30.  
  31. var  RspIndex:KeyNumArray;  {- working response pointer array -}
  32.      HomePath : String;
  33.  
  34. {- this array contains the start index to the response strings -}
  35. const KeyIndex : KeyNumArray =
  36.         (1, 4, 6, 6,10,14,17,20,22,25,
  37.         28,28,32,35,40,40,40,40,40,40,
  38.         49,51,55,59,63,63,64,69,74,76,
  39.         80,83,90,93,99,106,113);
  40.  
  41. {- this array contains the end index to the response strings -}
  42. const KeyEnd : KeyNumArray =
  43.         (3, 5, 9, 9,13,16,19,21,24,27,
  44.         32,32,34,39,48,48,48,48,48,48,
  45.         50,54,58,62,68,63,68,73,75,79,
  46.         82,89,92,98,105,112,116);
  47.  
  48. {=========================================================}
  49. {      String data for conjugations                       }
  50. {=========================================================}
  51.  
  52. const MaxCon = 7;
  53. type ConStr = string[8];
  54.      ConjArray = array[1..MaxCon] of ConStr;
  55. const Con1 : ConjArray =
  56.     (' are ',' we''re ',' you ',' your ',' I''ve ',' I''m ',' me ');
  57.       Con2 : ConjArray =
  58.     (' am ',' was ',' I ',' my ',' you''ve ',' you''re ',' !you ');
  59.  
  60.  
  61. {=========================================================}
  62. {     Other misc information needed by the program        }
  63. {=========================================================}
  64.  
  65. {- possible punctuation -}
  66. const PuncSet = [' ','.','!','?',','];
  67.  
  68. {- misc error messages -}
  69. const NoFileMsg = 'Sorry, I seem to have mis-placed the response files.';
  70.       LogicErrMsg = 'Hmmm, I seem to be having problems myself.';
  71.  
  72.  
  73. {=========================================================}
  74. {  drop leading and trailing spaces and punctuation       }
  75. {=========================================================}
  76. procedure Ctrim(var Xstr:string);
  77. begin
  78.     while (length(Xstr) > 0) and (Xstr[1] in PuncSet) do
  79.       delete(Xstr,1,1);
  80.     while (length(Xstr) > 0) and (Xstr[length(Xstr)] in PuncSet) do
  81.       dec(Xstr[0]);
  82. end;
  83.  
  84. {=========================================================}
  85. {        return a string in upper case                    }
  86. {=========================================================}
  87. function UpCopy(Wstr:string; Pos,Cnt:byte):string;
  88. var Xstr:string;
  89.     i:integer;
  90. begin
  91.   Xstr[0] := #0;
  92.   for i := 1 to Cnt do
  93.   begin
  94.     inc(Xstr[0]);
  95.     Xstr[i] := upcase(Wstr[pred(Pos+i)]);
  96.   end;
  97.   UpCopy := Xstr;
  98. end;
  99.  
  100. {=========================================================}
  101. {        Find keyword in Wstr                             }
  102. {=========================================================}
  103. {- a keyword is a relational word that we can respond to }
  104. {- see the keyword table to see the types of relational words}
  105. {- that are used. Returns "Key" pointing to keyword in table,}
  106. {- returns "Kpos" pointing to first char after keyword in Wstr}
  107. {- Returns function true if keyword found, or false if not}
  108. {- if no keyword found Key = pred(MaxKey), repeated string = MaxKey}
  109.  
  110. function FindKey(Wstr:string; var Kpos,Key:word):boolean;
  111. var Xstr:string;
  112. label Found;
  113. begin
  114.   Xstr := UpCopy(Wstr,1,length(Wstr));
  115.   Key := 0;
  116.   while Key < pred(MaxKey) do
  117.   begin
  118.     inc(Key);
  119.     Kpos := pos(KeyWords[Key],Xstr);
  120.     if Kpos > 0 then goto Found;
  121.   end;
  122.   FindKey := false;
  123.   Exit;
  124.  
  125. Found:
  126.   Kpos := Kpos + Length(KeyWords[Key]);
  127.   FindKey := true;
  128. end;
  129.  
  130.  
  131. {=========================================================}
  132. {   Take the right part of the string and conjugate it    }
  133. {   using the list of strings to be swapped               }
  134. {=========================================================}
  135.  
  136. procedure Conjugate(var Wstr,Cstr:string; Kpos:word);
  137. var i,Cp:word;
  138.  
  139.   {- try to conjugate the string -}
  140.   function ConSwap(var Cs1,Cs2:ConStr):boolean;
  141.   begin
  142.     ConSwap := false;
  143.     if UpCopy(Cstr,Cp,length(Cs1)) = UpCopy(Cs1,1,length(Cs1)) then
  144.     begin
  145.       Cstr := copy(Cstr,1,pred(Cp))+Cs2+
  146.               copy(Cstr,Cp+length(Cs1),length(Cstr));
  147.       Cp := pred(Cp+length(Cs2));
  148.       ConSwap := true;
  149.     end
  150.   end;
  151.  
  152. {-procedure Conjugate-}
  153. begin
  154.     Cstr := copy(Wstr,Kpos,length(Wstr));    {pull out the right part}
  155.     Ctrim(Cstr);                             {clean it up}
  156.     if length(Cstr) = 0 then Cstr := Wstr;   {if empty use entire string}
  157.     Cstr := ' '+Cstr+' ';                    {add working spaces}
  158.  
  159.     for i := 1 to MaxCon do
  160.     begin
  161.       Cp := 0;
  162.       while Cp < length(Cstr) do
  163.       begin
  164.         inc(Cp);
  165.         if not(ConSwap(Con1[i],Con2[i])) then
  166.             if ConSwap(Con2[i],Con1[i]) then {nop};
  167.       end;
  168.     end;
  169.  
  170.     {- clean up the conjugated string -}
  171.     Cp := 1;
  172.     while Cp < length(Cstr) do
  173.       if Cstr[Cp] = '!' then Delete(Cstr,Cp,1) else inc(Cp);
  174.     Ctrim(Cstr);
  175.  
  176.     {- special case fixup for trailing 'I's -}
  177.     if Cstr[length(Cstr)] = 'I' then
  178.     begin
  179.       dec(Cstr[0]);
  180.       Cstr := Cstr+'me';
  181.     end;
  182. end;
  183.  
  184.  
  185. {============================================================}
  186. {        Reads a response from the response file             }
  187. {============================================================}
  188. procedure ReadResp(var Rstr:string; RespNum:word);
  189. var i:integer;
  190.     Respfile:text;
  191. label NoFileErr,LogicErr;
  192. begin
  193.   if (RespNum = 0) or (RespNum > MaxRespNum) then goto LogicErr;
  194.  
  195.   {- find the desired response in the response file -}
  196.   assign(Respfile,HomePath+RespFn);
  197.   reset(Respfile);
  198.   for i := 1 to pred(RespNum) do
  199.      Readln(Respfile);      {skip down to the desired response}
  200.   Readln(Respfile,Rstr);    {read it}
  201.   close(Respfile);          {and close the file}
  202.   if IOResult <> 0 then goto NoFileErr;      {check for errors}
  203.   Exit;
  204.  
  205. {- couldn't find the file, or a read error occured -}
  206. NoFileErr:
  207.   Rstr := NoFileMsg;
  208.   Exit;
  209.  
  210. {- invalid response number given -}
  211. LogicErr:
  212.   Rstr := LogicErrMsg;
  213. end;
  214.  
  215.  
  216. {============================================================}
  217. { Get a response based on the keyword number in variable Key }
  218. {============================================================}
  219.  
  220. procedure GetResponse(var Rstr:string; Key:word);
  221. var Fstr:string;
  222. label QAppend,PAppend;
  223. begin
  224.   ReadResp(Fstr,RspIndex[Key]); {get the desired response from data file}
  225.  
  226.   {-Point to the next response so that no two are the same}
  227.   inc(RspIndex[Key]);
  228.   if RspIndex[Key] > KeyEnd[Key] then RspIndex[Key] := KeyIndex[Key];
  229.  
  230.   {-if no "*" or "@" at the end of the response, then just return the response}
  231.   {-if there was an "*" at the end of the response string, then return}
  232.   {-the response plus the conjugation word/phrase in Rstr plus a "?"}
  233.   {-if "@" then add a period instead}
  234.   if Fstr[length(Fstr)] = '*' then goto QAppend;
  235.   if Fstr[length(Fstr)] = '@' then goto PAppend;
  236.   Rstr := Fstr;
  237.   Exit;
  238.  
  239. {- replace the '*' with a space, append the conjugated string and add "?" -}
  240. QAppend:
  241.   Fstr[length(Fstr)] := ' ';
  242.   Rstr := Fstr+Rstr+'?';
  243.   Exit;
  244.  
  245. {- replace the '@' with a space, append the conjugated string and add "." -}
  246. PAppend:
  247.   Fstr[length(Fstr)] := ' ';
  248.   Rstr := Fstr+Rstr+'.';
  249. end;
  250.  
  251.  
  252. PROCEDURE RX (IStr : String); far;
  253.  
  254. VAR
  255.   Key,Kpos:word;          {- key word pointers -}
  256.   Cstr:string;  {- operational strings -}
  257.   Pstr:string;  {- operational strings -}
  258.  
  259. BEGIN
  260.   Dec(IStr[0]);
  261.   Ctrim(istr);   {- strip out any extra blanks from work string -}
  262.   Cstr := UpCopy(Istr,1,length(Istr));
  263.   IF (CStr = 'BYE') OR (CStr = 'GOOD BYE') THEN BEGIN
  264.     SendMacroString(#13'Good bye %n and feel free to join another session with me. :-)'#13);
  265.     PRogrammende := TRUE;
  266.   END ELSE BEGIN
  267.     Key := MaxKey;                   {- set max for repeat input -}
  268.     if Cstr <> Pstr then             {- get new key if not repeat -}
  269.     if FindKey(Cstr,Kpos,Key) then {- If keyword found in Istr -}
  270.       Conjugate(Istr,Cstr,Kpos);  {- then conjugate the string -}
  271.  
  272.     Pstr := UpCopy(Istr,1,length(Istr)); {- save original input string -}
  273.     GetResponse(Cstr,Key); {- Get response based on Keyword found -}
  274.     SendString(Cstr+#13+':');         {- and print the response -}
  275.   END;
  276. end;
  277.  
  278.  
  279.  
  280. PROCEDURE InitProc; far;
  281.  
  282. VAR
  283.   S  : String;
  284.  
  285. BEGIN
  286.    RspIndex := KeyIndex; {- start the index array -}
  287.    S := #13'Hi %n! I''m Eliza. I am your personal therapy computer.'#13;
  288.    SendMacroString(S);
  289.    S := 'Please tell me your problem.'#13+
  290.         '(Type "good bye" if you want to leave.)'#13#13':';
  291.    SendString(S);
  292. END;
  293.  
  294.  
  295. {============================================================}
  296. {- program Eliza -}
  297.  
  298.  
  299. begin
  300.    HomePath := ParamStr(0);
  301.    WHILE (Byte(HomePath[0]) > 0) AND (HomePath[Byte(HomePath[0])] <> '\') DO Dec(HomePath[0]);
  302.    Programmende := FALSE;
  303.    IF NOT TaskInit(@InitProc,@RX,NIL,NIL) THEN BEGIN
  304.      Writeln('Dieses Programm kann nur als Remote-Programm unter GP gestartet werden.');
  305.      Halt;
  306.    END;
  307.    Keep(0);
  308. end.
  309.